home *** CD-ROM | disk | FTP | other *** search
/ Night Owl 6 / Night Owl's Shareware - PDSI-006 - Night Owl Corp (1990).iso / 016a / gofer221.zip / STATIC.C < prev    next >
C/C++ Source or Header  |  1991-11-20  |  58KB  |  1,770 lines
  1. /* --------------------------------------------------------------------------
  2.  * static.c:    Copyright (c) Mark P Jones 1991.   All rights reserved.
  3.  *        See goferite.h for details and conditions of use etc...
  4.  *        Gofer version 2.21 November 1991
  5.  *
  6.  *        Last updated 07/11/91 mpj
  7.  *
  8.  * Static Analysis for Gofer
  9.  * ------------------------------------------------------------------------*/
  10.  
  11. #include "prelude.h"
  12. #include "storage.h"
  13. #include "connect.h"
  14. #include "errors.h"
  15.  
  16. /* --------------------------------------------------------------------------
  17.  * local function prototypes:
  18.  * ------------------------------------------------------------------------*/
  19.  
  20. static Void  local checkSynonym        Args((Tycon));
  21. static Void  local checkData        Args((Tycon));
  22. static List  local checkTypeLhs        Args((Int,Cell));
  23. static Cell  local varFindDup        Args((List));
  24. static Cell  local checkDeclType    Args((Int,List,Cell));
  25. static Cell  local findOffset        Args((Text,List));
  26. static Name  local makeConstr        Args((Cell,Cell,List,Int,Int));
  27.  
  28. static Int   local maximum        Args((Int,Int));
  29. static Int   local tyconRank        Args((Tycon));
  30. static Int   local maxRank        Args((Cell));
  31. static Type  local fullExpand        Args((Type));
  32. static Type  local instantiateSyn    Args((Type,Type));
  33.  
  34. static List  local typeVarsIn        Args((Cell,List));
  35. static List  local maybeAppendVar    Args((Cell,List));
  36. static Cell  local checkSigType        Args((Int,String,Cell,Cell));
  37. static Void  local checkClassConstraint Args((Int,List,Class));
  38. static Class local classDefined     Args((Int,Cell));
  39.  
  40. static List  local offsetTyvarsIn    Args((Type,List));
  41.  
  42. static Void  local checkClassDefn    Args((Class));
  43. static List  local addMemberFunctions    Args((Class,List,List));
  44. static Name  local newMember        Args((Int,Cell,Int,Type));
  45.  
  46. static Void  local checkInstDefn        Args((Inst));
  47.  
  48. static List  local classBindings        Args((String,Class,List));
  49. static Int   local memberNumber         Args((Class,Text));
  50. static List  local numInsert            Args((Int,Cell,List));
  51.  
  52. static Void  local addNewPrim        Args((Int,Text,String,Cell));
  53.  
  54. static Cell  local checkPat        Args((Int,Cell));
  55. static Cell  local checkMaybeCnkPat    Args((Int,Cell));
  56. static Cell  local checkApPat        Args((Int,Int,Cell));
  57. static Void  local addPatVar        Args((Int,Cell));
  58. static Name  local conDefined        Args((Int,Text));
  59. static Void  local checkIsCfun        Args((Int,Cell));
  60. static Void  local checkCfunArgs    Args((Int,Cell,Int));
  61.  
  62. static Cell  local bindPat        Args((Int,Cell));
  63. static Void  local bindPats        Args((Int,List));
  64.  
  65. static List  local extractSigdecls    Args((List));
  66. static List  local extractBindings    Args((List));
  67. static List  local eqnsToBindings    Args((List));
  68. static Void  local notDefined        Args((Int,List,Cell));
  69. static Cell  local findBinding        Args((Text,List));
  70. static Void  local addSigDecl        Args((List,Cell));
  71. static Void  local setType        Args((Int,Cell,Cell,List));
  72.  
  73. static List  local dependencyAnal    Args((List));
  74. static List  local topDependAnal    Args((List));
  75. static Void  local addDepField        Args((Cell));
  76. static Void  local remDepField        Args((List));
  77. static Void  local remDepField1        Args((Cell));
  78. static Void  local clearScope        Args((Void));
  79. static Void  local withinScope        Args((List));
  80. static Void  local leaveScope        Args((Void));
  81.  
  82. static Void  local depBinding        Args((Cell));
  83. static Void  local depDefaults          Args((Class));
  84. static Void  local depInsts             Args((Inst));
  85. static Void  local depClassBindings     Args((List));
  86. static Void  local depAlt        Args((Cell));
  87. static Void  local depRhs        Args((Cell));
  88. static Void  local depGuard        Args((Cell));
  89. static Cell  local depExpr        Args((Int,Cell));
  90. static Void  local depPair        Args((Int,Cell));
  91. static Void  local depTriple        Args((Int,Cell));
  92. static Void  local depListComp        Args((Int,Cell));
  93. static Void  local depQual        Args((Int,Cell));
  94. static Void  local depCaseAlt        Args((Int,Cell));
  95. static Cell  local depVar        Args((Int,Cell));
  96.  
  97. static Int   local sccMin        Args((Int,Int));
  98. static Int   local lowlink        Args((Cell));
  99. static List  local scc            Args((List));
  100.  
  101. static Void  local opDefined        Args((List,Cell));
  102. static Void  local allNoPrevDef        Args((Cell));
  103. static Void  local noPrevDef        Args((Int,Cell));
  104.  
  105. /* --------------------------------------------------------------------------
  106.  * Static analysis of type declarations:
  107.  *
  108.  * Type declarations come in two forms:
  109.  * - data declarations - define new constructed data types
  110.  * - type declarations - define new type synonyms
  111.  *
  112.  * A certain amount of work is carried out as the declarations are
  113.  * read during parsing.  In particular, for each type constructor
  114.  * definition encountered:
  115.  * - check that there is no previous definition of constructor
  116.  * - type constructor not previously used as a class name
  117.  * - make a new entry in the type constructor table
  118.  * - calculate arity
  119.  * - set rank to RANKUNKNOWN (for TYPE decls)
  120.  *         0         (for DATA decls)
  121.  * - record line number of declaration
  122.  * - Build separate lists of newly defined data and synonym
  123.  *   constructors for later use.
  124.  * ------------------------------------------------------------------------*/
  125.  
  126. #define RANKUNKNOWN  (-1)   /* Proper rank values are integers in [0..]    */
  127. #define RANKVISITING (-2)   /* (Constructed data types have rank 0)       */
  128.  
  129. Void newTypeDefn(line,l,r,dataDefn)    /* process new type definition       */
  130. Int  line;                   /* definition line number       */
  131. Cell l;                    /* left hand side of definition       */
  132. Cell r;                    /* right hand side           */
  133. Bool dataDefn; {               /* TRUE => data definition       */
  134.     Cell  t   = getHead(l);
  135.     Tycon new = findTycon(textOf(t));
  136.  
  137.     if (isNull(new)) {
  138.     if (nonNull(findClass(textOf(t)))) {
  139.         ERROR(line) "\"%s\" used as both class and type constructor",
  140.             textToStr(textOf(t))
  141.         EEND;
  142.     }
  143.     new = newTycon(textOf(t));
  144.     }
  145.     else if (tycon(new).defn!=PREDEFINED) {
  146.     ERROR(line) "Repeated definition of type constructor \"%s\"",
  147.             textToStr(textOf(t))
  148.     EEND;
  149.     }
  150.  
  151.     tycon(new).line  = line;
  152.     tycon(new).arity = argCount;
  153.     tycon(new).defn  = pair(l,r);
  154.     if (dataDefn) {
  155.     tycon(new).rank = 0;
  156.     dataDefns    = cons(new,dataDefns);
  157.     }
  158.     else {
  159.     tycon(new).rank = RANKUNKNOWN;
  160.     synonymDefns    = cons(new,synonymDefns);
  161.     }
  162. }
  163.  
  164. /* --------------------------------------------------------------------------
  165.  * Further analysis of Type declarations:
  166.  *
  167.  * In order to allow the definition of mutually recursive families of
  168.  * data types, the static analysis of the right hand sides of type
  169.  * declarations cannot be performed until all of the type declarations
  170.  * have been read.
  171.  *
  172.  * Once parsing is complete, we carry out the following:
  173.  * - check that there are no repeated type variables on lhs.
  174.  * - check that there are no free type variables on rhs.
  175.  * - check that all type constructors are defined and used with the
  176.  *   correct arity.
  177.  * - check that there are no previous definitions for constructor
  178.  *   functions in data type definitions.
  179.  * - install synonym expansions and constructor definitions.
  180.  * - replace type variables by Offsets, constructors by Tycons.
  181.  * ------------------------------------------------------------------------*/
  182.  
  183. static Void local checkSynonym(t)    /* validate synonym definition       */
  184. Tycon t; {
  185.     List tvars      = checkTypeLhs(tycon(t).line,fst(tycon(t).defn));
  186.     tycon(t).defn = checkDeclType(tycon(t).line,tvars,snd(tycon(t).defn));
  187. }
  188.  
  189. static Void local checkData(t)        /* validate datatype definition       */
  190. Tycon t; {
  191.     List tvars      = checkTypeLhs(tycon(t).line,fst(tycon(t).defn));
  192.     Int  constrNo = 0;
  193.     List cs      = snd(tycon(t).defn);
  194.     Int  arity      = length(tvars);
  195.     Cell lhs      = t;
  196.     Int  i;
  197.  
  198.     for (i=0; i<arity; ++i)
  199.     lhs = ap(lhs,mkOffset(i));
  200.  
  201.     for (constrNo=0; nonNull(cs); cs=tl(cs))
  202.     hd(cs) = makeConstr(hd(cs),lhs,tvars,constrNo++,tycon(t).line);
  203. }
  204.  
  205. static List local checkTypeLhs(line,lhs)/* check type on lhs of type defn  */
  206. Int line;
  207. Cell lhs; {
  208.     List tvars = getArgs(lhs);
  209.     Cell temp  = varFindDup(tvars);
  210.  
  211.     if (nonNull(temp)) {
  212.     ERROR(line) "Repeated type variable \"%s\" on left hand side",
  213.             textToStr(textOf(temp))
  214.     EEND;
  215.     }
  216.  
  217.     return tvars;
  218. }
  219.  
  220. static Cell local varFindDup(xs)    /* look for duplicates in var list */
  221. List xs; {
  222.     for (; nonNull(xs); xs=tl(xs))
  223.     if (nonNull(varIsMember(textOf(hd(xs)),tl(xs))))
  224.         return hd(xs);
  225.     return NIL;
  226. }
  227.  
  228. static Cell local checkDeclType(line,tvars,type)
  229. Int  line;                /* validate declared type expr       */
  230. Cell type;
  231. List tvars; {
  232.     Int arity = 0;
  233.     Cell t    = type;
  234.     Cell p    = NIL;
  235.  
  236.     if (isVar(type)) {
  237.     t = findOffset(textOf(type),tvars);
  238.     if (isNull(t)) {
  239.         ERROR(line) "Undefined type variable \"%s\"",
  240.                         textToStr(textOf(type))
  241.         EEND;
  242.     }
  243.     return t;
  244.     }
  245.  
  246.     while (isAp(t)) {
  247.     arg(t) = checkDeclType(line,tvars,arg(t));
  248.     p      = t;
  249.     t      = fun(t);
  250.     arity++;
  251.     }
  252.  
  253.     if (isCon(t)) {
  254.     Tycon tc = findTycon(textOf(t));
  255.  
  256.     if (isNull(tc)) {
  257.         ERROR(line) "Undefined type constructor \"%s\"",
  258.             textToStr(textOf(t))
  259.         EEND;
  260.     }
  261.     if (tycon(tc).arity != arity) {
  262.         ERROR(line) "Wrong number of arguments for \"%s\"",
  263.             textToStr(textOf(t))
  264.         EEND;
  265.     }
  266.     if (nonNull(p)) fun(p)=tc; else return tc;
  267.     }
  268.     return type;
  269. }
  270.  
  271. static Cell local findOffset(t,tvars)  /* translate variable t into offset */
  272. Text t;                    /* using list of variables tvars    */
  273. List tvars; {
  274.     Int offset;
  275.  
  276.     for (offset=0; nonNull(tvars); offset++) {
  277.     if (t==textOf(hd(tvars)))
  278.         return mkOffset(offset);
  279.     tvars = tl(tvars);
  280.     }
  281.     return NIL;
  282. }
  283.  
  284. static Name local makeConstr(c,type,tvars,constrNo,line) /* make constr fun*/
  285. Cell c;      /* constructor definition                   */
  286. Cell type;     /* left hand side of decl (used to construct type)       */
  287. List tvars;     /* list of (distinct) bound variables on lhs of defn       */
  288. Int constrNo;     /* constructor number (determines default order relation) */
  289. Int line; {     /* line number of definition                   */
  290.     Cell t;
  291.     Int  arity;
  292.     Name n;
  293.  
  294.     for (arity=0; isAp(c); arity++) {
  295.     t    = fun(c);
  296.     arg(c) = checkDeclType(line,tvars,arg(c));
  297.     fun(c) = ARROW;
  298.     type    = ap(c,type);
  299.     c    = t;
  300.     }
  301.  
  302.     n = findName(textOf(c));
  303.  
  304.     if (isNull(n))
  305.     n = newName(textOf(c));
  306.     else if (name(n).defn!=PREDEFINED) {
  307.     ERROR(line) "Repeated definition for constructor function \"%s\"",
  308.             textToStr(name(n).text)
  309.     EEND;
  310.     }
  311.  
  312.     name(n).line   = line;
  313.     name(n).arity  = arity;
  314.     name(n).number = constrNo;
  315.     name(n).type   = (nonNull(tvars)?pair(mkInt(length(tvars)),type):type);
  316.     name(n).defn   = CFUN;
  317.  
  318.     return n;
  319. }
  320.  
  321. /* --------------------------------------------------------------------------
  322.  * Calculate rank of type constructors in order to detect recursive and
  323.  * mutually recursive type synonym declarations.
  324.  * ------------------------------------------------------------------------*/
  325.  
  326. static Int local maximum(x,y)           /* integer maximum           */
  327. Int x, y; {
  328.     return (x>y) ? x : y;
  329. }
  330.  
  331. static Int local tyconRank(t)           /* calculate rank of type constr    */
  332. Tycon t; {
  333.     switch (tycon(t).rank) {
  334.     case RANKVISITING : ERROR(tycon(t).line)
  335.                    "Recursive type synonym \"%s\"",
  336.                    textToStr(tycon(t).text)
  337.                 EEND;
  338.                 break;
  339.     case RANKUNKNOWN  : tycon(t).rank = RANKVISITING;
  340.                 tycon(t).rank = 1 + maxRank(tycon(t).defn);
  341.                             tycon(t).defn = fullExpand(tycon(t).defn);
  342.                 break;
  343.     }
  344.     return tycon(t).rank;
  345. }
  346.  
  347. static Int local maxRank(t)           /* calculate maximum rank of type   */
  348. Cell t; {                   /* synonym constructors in type expr*/
  349.     Int highest = 0;
  350.  
  351.     for (highest=0; isAp(t); t=fun(t))
  352.     highest = maximum(highest,maxRank(arg(t)));
  353.     if (isTycon(t))
  354.     highest = maximum(highest,tyconRank(t));
  355.  
  356.     return highest;
  357. }
  358.  
  359. static Type local fullExpand(t)        /* find full expansion of type exp */
  360. Type t; {                /* assuming that all relevant      */
  361.     Cell h = t;                /* synonym defns of lower rank have*/
  362.     for (; isAp(h); h=fun(h))        /* already been fully expanded       */
  363.     arg(h) = fullExpand(arg(h));
  364.     if (isSynonym(h))
  365.         t = instantiateSyn(tycon(h).defn,t);
  366.     return t;
  367. }
  368.  
  369. static Type local instantiateSyn(t,env)    /* instantiate type according using*/
  370. Type t;                    /* env to determine appropriate    */
  371. Type env; {                /* values for OFFSET type vars       */
  372.     switch (whatIs(t)) {
  373.         case AP      : return ap(instantiateSyn(fun(t),env),
  374.                                  instantiateSyn(arg(t),env));
  375.  
  376.         case OFFSET  : return nthArg(offsetOf(t),env);
  377.  
  378.     default         : return t;
  379.     }
  380. }
  381.  
  382. /* --------------------------------------------------------------------------
  383.  * Type expressions appearing in type signature declarations and expressions
  384.  * also require static checking, but unlike type expressions in type decls,
  385.  * they may introduce arbitrary new type variables.  The static analysis
  386.  * required here is:
  387.  *   - ensure that each type constructor is defined and used with the
  388.  *     correct number of arguments.
  389.  *
  390.  *   - replace type variables by offsets, constructor names by Tycons.
  391.  * ------------------------------------------------------------------------*/
  392.  
  393. static List local typeVarsIn(type,vs)  /* calculate list of type variables */
  394. Cell type;                   /* used in type expression, reading */
  395. List vs; {                   /* from left to right           */
  396.     switch (whatIs(type)) {
  397.     case AP        : return typeVarsIn(snd(type),
  398.                        typeVarsIn(fst(type),
  399.                               vs));
  400.     case VARIDCELL :
  401.     case VAROPCELL : return maybeAppendVar(type,vs);
  402.  
  403.     case QUAL      : {   List qs = fst(snd(type));
  404.                  for (; nonNull(qs); qs=tl(qs))
  405.                  vs = typeVarsIn(hd(qs),vs);
  406.                  return typeVarsIn(snd(snd(type)),vs);
  407.              }
  408.     }
  409.     return vs;
  410. }
  411.  
  412. static List local maybeAppendVar(v,vs) /* append variable to list if not   */
  413. Cell v;                    /* already included           */
  414. List vs; {
  415.     Text t = textOf(v);
  416.     List p = NIL;
  417.     List c = vs;
  418.  
  419.     while (nonNull(c)) {
  420.     if (textOf(hd(c))==t)
  421.         return vs;
  422.     p = c;
  423.     c = tl(c);
  424.     }
  425.  
  426.     if (nonNull(p))
  427.     tl(p) = cons(v,NIL);
  428.     else
  429.     vs    = cons(v,NIL);
  430.  
  431.     return vs;
  432. }
  433.  
  434. static Cell local checkSigType(line,where,e,type)
  435. Int    line;                   /* check validity of type expression*/
  436. String where;                   /* in explicit type signature       */
  437. Cell   e;
  438. Type   type; {
  439.     List tvars = typeVarsIn(type,NIL);
  440.     Int  n     = length(tvars);
  441.  
  442.     if (whatIs(type)==QUAL) {
  443.     map2Proc(checkClassConstraint,line,tvars,fst(snd(type)));
  444.     snd(snd(type)) = checkDeclType(line,tvars,snd(snd(type)));
  445.  
  446.     if (isAmbiguous(type))
  447.         ambigError(line,where,e,type);
  448.     }
  449.     else
  450.     type = checkDeclType(line,tvars,type);
  451.  
  452.     return n>0 ? pair(mkInt(n),type) : type;
  453. }
  454.  
  455. static Void local checkClassConstraint(line,tvars,cl)
  456. Int  line;                   /* check class constraint in type...*/
  457. List tvars;
  458. Cell cl; {
  459.     Int  args = 0;
  460.     Cell prev = NIL;
  461.     Cell temp = cl;
  462.  
  463.     do {                /* parser ensures no. args >= 1       */
  464.     arg(temp) = checkDeclType(line,tvars,arg(temp));
  465.     prev    = temp;
  466.     temp      = fun(temp);
  467.     args++;
  468.     } while (isAp(temp));
  469.  
  470.     fun(prev) = classDefined(line,temp);
  471.     if (args!=class(fun(prev)).arity) {
  472.     ERROR(line) "Wrong number of arguments for class \"%s\"",
  473.             textToStr(class(fun(prev)).text)
  474.     EEND;
  475.     }
  476. }
  477.  
  478. static Class local classDefined(line,cv)
  479. Int  line;                   /* check that class name is defined */
  480. Cell cv; {                   /* cv :: CONIDCELL           */
  481.     Class c = findClass(textOf(cv));
  482.  
  483.     if (isNull(c)) {
  484.     ERROR(line) "Undefined class \"%s\"", textToStr(textOf(cv))
  485.     EEND;
  486.     }
  487.     return c;
  488. }
  489.  
  490. /* --------------------------------------------------------------------------
  491.  * Check for ambiguous types:
  492.  * A type  Preds => type  is ambiguous if not (TV(P) `subset` TV(type))
  493.  * ------------------------------------------------------------------------*/
  494.  
  495. static List local offsetTyvarsIn(t,vs)    /* add list of offset tyvars in t  */
  496. Type t;                    /* to list vs               */
  497. List vs; {
  498.     switch (whatIs(t)) {
  499.     case AP        : return offsetTyvarsIn(fun(t),offsetTyvarsIn(snd(t),vs));
  500.  
  501.     case OFFSET : if (cellIsMember(t,vs))
  502.               return vs;
  503.               else
  504.               return cons(t,vs);
  505.  
  506.     case QUAL   : return offsetTyvarsIn(snd(t),vs);
  507.  
  508.     default        : return vs;
  509.     }
  510. }
  511.  
  512. Bool isAmbiguous(type)            /* Determine whether type is       */
  513. Type type; {                /* ambiguous                */
  514.     if (isPolyType(type))
  515.     type = snd(type);
  516.     if (whatIs(type)==QUAL) {        /* only qualified types can be       */
  517.     List tvps = offsetTyvarsIn(fst(snd(type)),NIL);    /* ambiguous       */
  518.     List tvts = offsetTyvarsIn(snd(snd(type)),NIL);
  519.     while (nonNull(tvps) && cellIsMember(hd(tvps),tvts))
  520.         tvps = tl(tvps);
  521.     return nonNull(tvps);
  522.     }
  523.     return FALSE;
  524. }
  525.  
  526. Void ambigError(line,where,e,type)    /* produce error message for       */
  527. Int    line;                /* ambiguity               */
  528. String where;
  529. Cell   e;
  530. Type   type; {
  531.     ERROR(line) "Ambiguous type signature in %s", where ETHEN
  532.     ERRTEXT "\n*** ambiguous type : " ETHEN ERRTYPE(type);
  533.     ERRTEXT "\n*** assigned to    : " ETHEN ERREXPR(e);
  534.     ERRTEXT "\n"
  535.     EEND;
  536. }
  537.  
  538. /* --------------------------------------------------------------------------
  539.  * Static analysis of class declarations:
  540.  *
  541.  * Performed in a similar manner to that used for type declarations.
  542.  *
  543.  * The first part of the static analysis is performed as the declarations
  544.  * are read during parsing:
  545.  * - no previous definition for class
  546.  * - class name not previously used as a type constructor
  547.  * - make new entry in class table
  548.  * - determine arity of class
  549.  * - record line number of declaration
  550.  * - build list of classes defined in current script for use in later
  551.  *   stages of static analysis.
  552.  * ------------------------------------------------------------------------*/
  553.  
  554. Void classDefn(line,head,ms)           /* process new class definition       */
  555. Int  line;                   /* definition line number       */
  556. Cell head;                   /* class header :: ([Supers],Class) */
  557. List ms; {                   /* class definition body           */
  558.     Text  ct    = textOf(getHead(snd(head)));
  559.     Int   arity = argCount;
  560.     Class new   = findClass(ct);
  561.  
  562.     if (isNull(new)) {
  563.     if (nonNull(findTycon(ct))) {
  564.         ERROR(line) "\"%s\" used as both class and type constructor",
  565.             textToStr(ct)
  566.         EEND;
  567.     }
  568.     new = newClass(ct);
  569.     }
  570.     else if (class(new).head!=PREDEFINED) {
  571.     ERROR(line) "Repeated definition of type class \"%s\"",
  572.             textToStr(ct)
  573.     EEND;
  574.     }
  575.  
  576.     class(new).arity    = arity;
  577.     class(new).line    = line;
  578.     class(new).head     = snd(head);
  579.     class(new).supers    = fst(head);
  580.     class(new).members    = ms;
  581.     classDefns        = cons(new,classDefns);
  582. }
  583.  
  584. /* --------------------------------------------------------------------------
  585.  * Further analysis of class declarations:
  586.  *
  587.  * Full static analysis of class definitions must be postponed until the
  588.  * complete script has been read and all static analysis on type definitions
  589.  * has been completed.
  590.  *
  591.  * Once this has been achieved, we carry out the following checks on each
  592.  * class definition:
  593.  *
  594.  * - each named superclass has been defined
  595.  * - replace class(...).supers with a list of superclass skeletons
  596.  *
  597.  * - split body of class into members and declarations
  598.  * - make new name entry for each member function
  599.  * - record member function number (eventually an offset into dictionary!)
  600.  * - no member function has a previous definition ...
  601.  * - no member function is mentioned more than once in the list of members
  602.  * - each member function type is valid, replace vars by offsets
  603.  * - qualify each member function type by class header
  604.  * - only bindings for members appear in defaults
  605.  * - only function bindings appear in defaults
  606.  * ------------------------------------------------------------------------*/
  607.  
  608. static Void local checkClassDefn(c)    /* validate class definition       */
  609. Class c; {
  610.     List tvars = NIL;
  611.     Int  args  = 0;
  612.     Int  i;
  613.     Cell temp;
  614.  
  615.     /* build list of type variables in class header */
  616.  
  617.     for (temp=class(c).head; isAp(temp); temp=fun(temp)) {
  618.     if (!isVar(arg(temp))) {
  619.         ERROR(class(c).line) "Type variable required in class header"
  620.         EEND;
  621.     }
  622.     if (nonNull(varIsMember(textOf(arg(temp)),tvars))) {
  623.         ERROR(class(c).line)
  624.         "Repeated type variable \"%s\" in class header",
  625.         textToStr(textOf(arg(temp)))
  626.         EEND;
  627.     }
  628.     tvars = cons(arg(temp),tvars);
  629.     args++;
  630.     }
  631.  
  632.     for (temp=class(c).head, i=args-1; i>0; temp=fun(temp), i--)
  633.     arg(temp) = mkOffset(i);
  634.     arg(temp) = mkOffset(0);
  635.     fun(temp) = c;
  636.  
  637.     map2Proc(checkClassConstraint,class(c).line,tvars,class(c).supers);
  638.     class(c).numSupers  = length(class(c).supers);
  639.     temp            = extractBindings(class(c).members);
  640.     class(c).members    = addMemberFunctions(c,
  641.                        tvars,
  642.                        extractSigdecls(class(c).members));
  643.     class(c).numMembers = length(class(c).members);
  644.     class(c).defaults   = classBindings("class",c,temp);
  645. }
  646.  
  647. static List local addMemberFunctions(c,tvars,ms)
  648. Class c;
  649. List  tvars;
  650. List  ms; {        /* :: [ (Line,[Var],type) ] */
  651.     List mfuns = NIL;    /* List of member functions */
  652.     Int  mno   = 1;    /* Member function number   */
  653.     List qs    = cons(class(c).head,NIL);
  654.  
  655.     for (; nonNull(ms); ms=tl(ms)) {   /* cycle through each sigdecl */
  656.     Int  line = intOf(fst3(hd(ms)));
  657.     List vs   = snd3(hd(ms));
  658.     Type t      = thd3(hd(ms));
  659.  
  660.         tvars     = typeVarsIn(t,tvars);
  661.     t      = pair(mkInt(length(tvars)),
  662.              ap(QUAL,pair(qs,
  663.                       checkDeclType(line,tvars,t))));
  664.  
  665.     if (isAmbiguous(t))
  666.         ambigError(line,"class declaration",hd(vs),t);
  667.  
  668.     for (; nonNull(vs); vs=tl(vs))
  669.         mfuns = cons(newMember(line,hd(vs),mno++,t),mfuns);
  670.  
  671.     tvars = take(class(c).arity,tvars);    /* delete additional tvars */
  672.     }
  673.     return rev(mfuns);
  674. }
  675.  
  676. static Name local newMember(line,v,no,t)
  677. Int  line;
  678. Cell v;
  679. Int  no;
  680. Type t; {
  681.     Name m = findName(textOf(v));
  682.  
  683.     if (isNull(m))
  684.     m = newName(textOf(v));
  685.     else if (name(m).defn!=PREDEFINED) {
  686.     ERROR(line) "Repeated definition for member function \"%s\"",
  687.              textToStr(name(m).text)
  688.     EEND;
  689.     }
  690.  
  691.     name(m).line   = line;
  692.     name(m).arity  = 1;
  693.     name(m).number = no;
  694.     name(m).type   = t;
  695.     name(m).defn   = MFUN;
  696.  
  697.     return m;
  698. }
  699.  
  700. /* --------------------------------------------------------------------------
  701.  * Static analysis of instance declarations:
  702.  *
  703.  * The first part of the static analysis is performed as the declarations
  704.  * are read during parsing:
  705.  * - make new entry in instance table
  706.  * - record line number of declaration
  707.  * - build list of instances defined in current script for use in later
  708.  *   stages of static analysis.
  709.  * ------------------------------------------------------------------------*/
  710.  
  711. Void instDefn(line,head,ms)           /* process new instance definition  */
  712. Int  line;                   /* definition line number       */
  713. Cell head;                   /* inst header :: (context,Class)   */
  714. List ms; {                   /* instance members           */
  715.     Inst new             = newInst();
  716.     inst(new).line       = line;
  717.     inst(new).specifics  = fst(head);
  718.     inst(new).head     = snd(head);
  719.     inst(new).implements = ms;
  720.     instDefns            = cons(new,instDefns);
  721. }
  722.  
  723. /* --------------------------------------------------------------------------
  724.  * Further static analysis of instance declarations:
  725.  *
  726.  * Makes the following checks:
  727.  * - Class part of header is a valid class expression C t1 ... tn not
  728.  *   overlapping with any other instance in class C.
  729.  * - Each element of context is a valid class expression, with type vars
  730.  *   drawn from the types t1,...,tn.
  731.  * - replace type vars in class header by offsets, validate all types etc.
  732.  * - All bindings are function bindings
  733.  * - All bindings define member functions for class C
  734.  * - Arrange bindings into appropriate order for member list
  735.  * - No top level type signature declarations
  736.  * ------------------------------------------------------------------------*/
  737.  
  738. static Void local checkInstDefn(in)    /* validate instance declaration    */
  739. Inst in; {
  740.     Int  line  = inst(in).line;
  741.     List tvars = typeVarsIn(inst(in).head,NIL);
  742.     List ins;
  743.  
  744.     checkClassConstraint(line,tvars,inst(in).head);
  745.     map2Proc(checkClassConstraint,line,tvars,inst(in).specifics);
  746.  
  747.     inst(in).cl      = getHead(inst(in).head);
  748.     inst(in).freedom = length(tvars);
  749.  
  750.     for (ins=class(inst(in).cl).instances; nonNull(ins); ins=tl(ins)) {
  751.         Cell pi = instsOverlap(in,hd(ins));
  752.     if (nonNull(pi)) {
  753.         ERROR(line) "Overlapping instances for class \"%s\"",
  754.             textToStr(class(inst(in).cl).text)
  755.         ETHEN
  756.         ERRTEXT "\n*** This instance   : " ETHEN ERRPRED(inst(in).head);
  757.         ERRTEXT "\n*** Overlaps with   : " ETHEN
  758.                            ERRPRED(inst(hd(ins)).head);
  759.         ERRTEXT "\n*** Common instance : " ETHEN
  760.                            ERRPRED(pi);
  761.         ERRTEXT "\n"
  762.         EEND;
  763.     }
  764.     }
  765.  
  766.     class(inst(in).cl).instances
  767.               = cons(in,class(inst(in).cl).instances);
  768.     inst(in).numSpecifics = length(inst(in).specifics);
  769.  
  770.     if (nonNull(extractSigdecls(inst(in).implements))) {
  771.         ERROR(line) "Type signature decls not permitted in instance decl"
  772.         EEND;
  773.     }
  774.  
  775.     inst(in).implements = classBindings("instance",
  776.                                         inst(in).cl,
  777.                                         extractBindings(inst(in).implements));
  778. }
  779.  
  780. /* --------------------------------------------------------------------------
  781.  * Process class and instance declaration binding groups:
  782.  * ------------------------------------------------------------------------*/
  783.  
  784. static List local classBindings(where,c,bs)
  785. String where;                          /* check validity of bindings bs for*/
  786. Class  c;                              /* class c (or an instance of c)    */
  787. List   bs; {                           /* sort into approp. member order   */
  788.     List nbs = NIL;
  789.  
  790.     for (; nonNull(bs); bs=tl(bs)) {
  791.         Cell b  = hd(bs);
  792.         Name nm = newName(inventText());   /* pick name for implementation */
  793.         Int  mno;
  794.  
  795.         if (!isVar(fst(b))) {          /* only allows function bindings    */
  796.             ERROR(rhsLine(snd(snd(snd(b)))))
  797.                "Pattern binding illegal in %s declaration", where
  798.             EEND;
  799.         }
  800.  
  801.         mno = memberNumber(c,textOf(fst(b)));
  802.  
  803.         if (mno==0) {
  804.             ERROR(rhsLine(snd(hd(snd(snd(b))))))
  805.                 "No member \"%s\" in class \"%s\"",
  806.                 textToStr(textOf(fst(b))),
  807.                 textToStr(class(c).text)
  808.             EEND;
  809.         }
  810.  
  811.         name(nm).defn = snd(snd(b));   /* save definition of implementation*/
  812.         nbs = numInsert(mno-1,nm,nbs);
  813.     }
  814.     return nbs;
  815. }
  816.  
  817. static Int local memberNumber(c,t)     /* return number of member function */
  818. Class c;                               /* with name t in class c           */
  819. Text  t; {                             /* return 0 if not a member         */
  820.     List ms = class(c).members;
  821.     for (; nonNull(ms); ms=tl(ms))
  822.         if (t==name(hd(ms)).text)
  823.             return name(hd(ms)).number;
  824.     return 0;
  825. }
  826.  
  827. static List local numInsert(n,x,xs)    /* insert x at nth position in xs,  */
  828. Int  n;                                /* filling gaps with NIL            */
  829. Cell x;
  830. List xs; {
  831.     List start = isNull(xs) ? cons(NIL,NIL) : xs;
  832.  
  833.     for (xs=start; 0<n--; xs=tl(xs))
  834.         if (isNull(tl(xs)))
  835.             tl(xs) = cons(NIL,NIL);
  836.     hd(xs) = x;
  837.     return start;
  838. }
  839.  
  840. /* --------------------------------------------------------------------------
  841.  * Primitive definitions are usually only included in the first script
  842.  * file read - the prelude.  A primitive definition associates a variable
  843.  * name with a string (which identifies a built-in primitive) and a type.
  844.  * ------------------------------------------------------------------------*/
  845.  
  846. Void primDefn(line,prims,type)           /* Handle primitive definitions       */
  847. Int  line;
  848. List prims;
  849. Cell type; {
  850.     type = checkSigType(line,"primitive",fst(hd(prims)),type);
  851.     for (; nonNull(prims); prims=tl(prims))
  852.     addNewPrim(line,
  853.            textOf(fst(hd(prims))),
  854.            textToStr(textOf(snd(hd(prims)))),
  855.            type);
  856. }
  857.  
  858. static Void local addNewPrim(l,vn,s,t)    /* make binding of variable vn to  */
  859. Int    l;                /* primitive function referred       */
  860. Text   vn;                /* to by s, with given type t       */
  861. String s;                /* return TRUE if vn already bound */
  862. Cell   t;{
  863.     Name n = findName(vn);
  864.     Int  i;
  865.  
  866.     if (isNull(n))
  867.         n = newName(vn);
  868.     else if (name(n).defn!=PREDEFINED) {
  869.         ERROR(l) "Redeclaration of primitive \"%s\"", textToStr(vn)
  870.         EEND;
  871.     }
  872.  
  873.     name(n).line = l;
  874.     for (i=0; primitives[i].ref; ++i)
  875.         if (strcmp(s,primitives[i].ref)==0) {
  876.             addPrim(n,primitives[i].arity,t,primitives[i].imp);
  877.             return;
  878.         }
  879.     ERROR(l) "Unknown primitive reference \"%s\"", s
  880.     EEND;
  881. }
  882.  
  883. /* --------------------------------------------------------------------------
  884.  * Static analysis of patterns:
  885.  *
  886.  * Patterns are parsed as ordinary (atomic) expressions.  Static analysis
  887.  * makes the following checks:
  888.  *  - Patterns are well formed (according to pattern syntax), including the
  889.  *    special case of (n+k) patterns.
  890.  *  - All constructor functions have been defined and are used with the
  891.  *    correct number of arguments.
  892.  *  - No variable name is used more than once in a pattern.
  893.  *
  894.  * The list of pattern variables occuring in each pattern is accumulated in
  895.  * a global list `patVars', which must be initialised to NIL at appropriate
  896.  * points before using these routines to check for valid patterns.  This
  897.  * mechanism enables the pattern checking routine to be mapped over a list
  898.  * of patterns, ensuring that no variable occurs more than once in the
  899.  * complete pattern list (as is required on the lhs of a function defn).
  900.  * ------------------------------------------------------------------------*/
  901.  
  902. static List patVars;               /* list of vars bound in pattern    */
  903.  
  904. static Cell local checkPat(line,p)     /* Check valid pattern syntax       */
  905. Int  line;
  906. Cell p; {
  907.     switch (whatIs(p)) {
  908.     case VARIDCELL :
  909.     case VAROPCELL : addPatVar(line,p);
  910.              break;
  911.  
  912.     case AP        : return checkMaybeCnkPat(line,p);
  913.  
  914.     case NAME      :
  915.     case CONIDCELL :
  916.     case CONOPCELL : return checkApPat(line,0,p);
  917.  
  918.     case UNIT      :
  919.     case WILDCARD  :
  920.     case STRCELL   :
  921.     case CHARCELL  :
  922.     case INTCELL   : break;
  923.  
  924.     case ASPAT     : addPatVar(line,fst(snd(p)));
  925.              snd(snd(p)) = checkPat(line,snd(snd(p)));
  926.              break;
  927.  
  928.     case LAZYPAT   : snd(p) = checkPat(line,snd(p));
  929.              break;
  930.  
  931.     case FINLIST   : map1Over(checkPat,line,snd(p));
  932.              break;
  933.  
  934.     default        : ERROR(line) "Illegal pattern syntax"
  935.              EEND;
  936.     }
  937.     return p;
  938. }
  939.  
  940. static Cell local checkMaybeCnkPat(l,p)/* Check applicative pattern with   */
  941. Int  l;                       /* the possibility of c*n or n+k    */
  942. Cell p; {                   /* pattern               */
  943.     Text t = textOf(getHead(p));
  944.  
  945.     if (argCount==2 && t==textPlus) {  /* n+k pattern               */
  946.         Cell v = arg(fun(p));
  947.     if (!isInt(arg(p))) {
  948.         ERROR(l) "Second argument in (n+k) pattern must be an integer"
  949.         EEND;
  950.     }
  951.     if (intOf(arg(p))<=0) {
  952.         ERROR(l) "Integer k in (n+k) pattern must be > 0"
  953.         EEND;
  954.     }
  955.     fst(fun(p))     = ADDPAT;
  956.     intValOf(fun(p)) = intOf(arg(p));
  957.     arg(p)         = checkPat(l,v);
  958.     return p;
  959.     }
  960.  
  961.     if (argCount==2 && t==textMult) {  /* c*n pattern               */
  962.     if (!isInt(arg(fun(p)))) {
  963.         ERROR(l) "First argument in (c*n) pattern must be an integer"
  964.         EEND;
  965.     }
  966.     if (intOf(arg(fun(p)))<=1) {
  967.         ERROR(l) "Integer c in (c*n) pattern must be > 1"
  968.         EEND;
  969.     }
  970.         fst(fun(p))      = MULPAT;
  971.     intValOf(fun(p)) = intOf(arg(fun(p)));
  972.         arg(p)           = checkPat(l,arg(p));
  973.     return p;
  974.     }
  975.  
  976.     return checkApPat(l,0,p);
  977. }
  978.  
  979. static Cell local checkApPat(line,args,p)
  980. Int  line;                   /* check validity of application    */
  981. Int  args;                   /* of constructor to arguments       */
  982. Cell p; {
  983.     switch (whatIs(p)) {
  984.     case AP        : fun(p) = checkApPat(line,args+1,fun(p));
  985.              arg(p) = checkPat(line,arg(p));
  986.              break;
  987.  
  988.     case TUPLE     : if (tupleOf(p)!=args)
  989.                  internal("bad pattern tuple");
  990.              break;
  991.  
  992.     case CONIDCELL :
  993.     case CONOPCELL : p = conDefined(line,textOf(p));
  994.              checkCfunArgs(line,p,args);
  995.              break;
  996.  
  997.     case NAME      : checkIsCfun(line,p);
  998.              checkCfunArgs(line,p,args);
  999.              break;
  1000.  
  1001.     default        : ERROR(line) "Illegal pattern syntax"
  1002.              EEND;
  1003.     }
  1004.     return p;
  1005. }
  1006.  
  1007. static Void local addPatVar(line,v)    /* add variable v to list of vars   */
  1008. Int  line;                   /* in current pattern, checking for */
  1009. Cell v; {                   /* repeated variables.           */
  1010.      Text t = textOf(v);
  1011.      List p = NIL;
  1012.      List n = patVars;
  1013.  
  1014.      for (; nonNull(n); p=n, n=tl(n))
  1015.      if (textOf(hd(n))==t) {
  1016.          ERROR(line) "Repeated variable \"%s\" in pattern",
  1017.              textToStr(t)
  1018.          EEND;
  1019.      }
  1020.  
  1021.      if (isNull(p))
  1022.      patVars = cons(v,NIL);
  1023.      else
  1024.      tl(p)     = cons(v,NIL);
  1025. }
  1026.  
  1027. static Name local conDefined(line,t)   /* check that t is the name of a    */
  1028. Int line;                   /* previously defined constructor   */
  1029. Text t; {                   /* function.               */
  1030.     Cell c=findName(t);
  1031.     if (isNull(c)) {
  1032.     ERROR(line) "Undefined constructor function \"%s\"", textToStr(t)
  1033.     EEND;
  1034.     }
  1035.     checkIsCfun(line,c);
  1036.     return c;
  1037. }
  1038.  
  1039. static Void local checkIsCfun(line,c)  /* Check that c is a constructor fn */
  1040. Int  line;
  1041. Cell c; {
  1042.     if (name(c).defn!=CFUN) {
  1043.     ERROR(line) "\"%s\" is not a constructor function",
  1044.             textToStr(name(c).text)
  1045.     EEND;
  1046.     }
  1047. }
  1048.  
  1049. static Void local checkCfunArgs(line,c,args)
  1050. Int  line;                   /* Check constructor applied with   */
  1051. Cell c;                    /* correct number of arguments       */
  1052. Int  args; {
  1053.     if (name(c).arity!=args) {
  1054.     ERROR(line) "Constructor function \"%s\" needs %d args in pattern",
  1055.             textToStr(name(c).text), name(c).arity
  1056.     EEND;
  1057.     }
  1058. }
  1059.  
  1060. /* --------------------------------------------------------------------------
  1061.  * Maintaining lists of bound variables and local definitions, for
  1062.  * dependency and scope analysis.
  1063.  * ------------------------------------------------------------------------*/
  1064.  
  1065. static List bounds;               /* list of lists of bound vars       */
  1066. static List bindings;               /* list of lists of binds in scope  */
  1067. static List depends;               /* list of lists of dependents       */
  1068.  
  1069. #define saveBvars()     hd(bounds)    /* list of bvars in current scope   */
  1070. #define restoreBvars(bs) hd(bounds)=bs /* restore list of bound variables  */
  1071.  
  1072. static Cell local bindPat(line,p)      /* add new bound vars for pattern   */
  1073. Int  line;
  1074. Cell p; {
  1075.     patVars    = NIL;
  1076.     p           = checkPat(line,p);
  1077.     hd(bounds) = revOnto(patVars,hd(bounds));
  1078.     return p;
  1079. }
  1080.  
  1081. static Void local bindPats(line,ps)    /* add new bound vars for patterns  */
  1082. Int  line;
  1083. List ps; {
  1084.     patVars    = NIL;
  1085.     map1Over(checkPat,line,ps);
  1086.     hd(bounds) = revOnto(patVars,hd(bounds));
  1087. }
  1088.  
  1089. /* --------------------------------------------------------------------------
  1090.  * Before processing value and type signature declarations, all data and
  1091.  * type definitions have been processed so that:
  1092.  * - all valid type constructors (with their arities) are known.
  1093.  * - all valid constructor functions (with their arities and types) are
  1094.  *   known.
  1095.  *
  1096.  * The result of parsing a list of value declarations is a list of Eqns:
  1097.  *     Eqn ::= (SIGDECL,(Line,[Var],type))  |  (Expr,Rhs)
  1098.  * The ordering of the equations in this list is the reverse of the original
  1099.  * ordering in the script parsed.  This is a consequence of the structure of
  1100.  * the parser ... but also turns out to be most convenient for the static
  1101.  * analysis.
  1102.  *
  1103.  * As the first stage of the static analysis of value declarations, each
  1104.  * list of Eqns is converted to a list of Bindings.  As part of this
  1105.  * process:
  1106.  * - The ordering of the list of Bindings produced is the same as in the
  1107.  *   original script.
  1108.  * - When a variable (function) is defined over a number of lines, all
  1109.  *   of the definitions should appear together and each should give the
  1110.  *   same arity to the variable being defined.
  1111.  * - No variable can have more than one definition.
  1112.  * - For pattern bindings:
  1113.  *   - Each lhs is a valid pattern/function lhs, all constructor functions
  1114.  *     have been defined and are used with the correct number of arguments.
  1115.  *   - Each lhs contains no repeated pattern variables.
  1116.  *   - Each equation defines at least one variable (e.g. True = False is
  1117.  *     not allowed).
  1118.  * - Types appearing in type signatures are well formed:
  1119.  *    - Type constructors used are defined and used with correct number
  1120.  *    of arguments.
  1121.  *    - type variables are replaced by offsets, type constructor names
  1122.  *    by Tycons.
  1123.  * - Every variable named in a type signature declaration is defined by
  1124.  *   one or more equations elsewhere in the script.
  1125.  * - No variable has more than one type declaration.
  1126.  *
  1127.  * ------------------------------------------------------------------------*/
  1128.  
  1129. #define bindingType(b) fst(snd(b))     /* type (or types) for binding       */
  1130. #define fbindAlts(b)   snd(snd(b))     /* alternatives for function binding*/
  1131.  
  1132. static List local extractSigdecls(es)  /* extract the SIGDECLS from list   */
  1133. List es; {                   /* of equations               */
  1134.     List sigDecls  = NIL;           /* :: [(Line,[Var],Type)]       */
  1135.  
  1136.     for(; nonNull(es); es=tl(es))
  1137.     if (fst(hd(es))==SIGDECL)             /* type-declaration?  */
  1138.         sigDecls = cons(snd(hd(es)),sigDecls);   /* discard SIGDECL tag*/
  1139.  
  1140.     return sigDecls;
  1141. }
  1142.  
  1143. static List local extractBindings(es)  /* extract untyped bindings from    */
  1144. List es; {                   /* given list of equations       */
  1145.     Cell lastVar   = NIL;           /* = var def'd in last eqn (if any) */
  1146.     Int  lastArity = 0;            /* = number of args in last defn    */
  1147.     List bs       = NIL;           /* :: [Binding]               */
  1148.  
  1149.     for(; nonNull(es); es=tl(es)) {
  1150.     Cell e = hd(es);
  1151.  
  1152.     if (fst(e)!=SIGDECL) {
  1153.         Int  line     = rhsLine(snd(e));
  1154.         Cell lhsHead = getHead(fst(e));
  1155.  
  1156.         switch (whatIs(lhsHead)) {
  1157.         case VARIDCELL :
  1158.         case VAROPCELL : {              /* function-binding? */
  1159.             Cell newAlt = pair(getArgs(fst(e)), snd(e));
  1160.             if (nonNull(lastVar) && textOf(lhsHead)==textOf(lastVar)) {
  1161.             if (argCount!=lastArity) {
  1162.                 ERROR(line)
  1163.                 "Equations give different arities for \"%s\"",
  1164.                 textToStr(textOf(lhsHead))
  1165.                 EEND;
  1166.             }
  1167.             fbindAlts(hd(bs)) = cons(newAlt,fbindAlts(hd(bs)));
  1168.             }
  1169.             else {
  1170.             lastVar   = lhsHead;
  1171.             lastArity = argCount;
  1172.             notDefined(line,bs,lhsHead);
  1173.             bs      = cons(pair(lhsHead,
  1174.                           pair(NIL,
  1175.                            singleton(newAlt))),
  1176.                      bs);
  1177.             }
  1178.         }
  1179.         break;
  1180.  
  1181.         case CONOPCELL :
  1182.         case CONIDCELL :
  1183.         case FINLIST   :
  1184.         case TUPLE     :
  1185.         case UNIT      :
  1186.         case ASPAT     : lastVar = NIL;       /* pattern-binding?  */
  1187.                  patVars = NIL;
  1188.                  fst(e)  = checkPat(line,fst(e));
  1189.                  if (isNull(patVars)) {
  1190.                      ERROR(line)
  1191.                       "No variables defined in lhs pattern"
  1192.                      EEND;
  1193.                  }
  1194.                  map2Proc(notDefined,line,bs,patVars);
  1195.                  bs = cons(pair(patVars,pair(NIL,e)),bs);
  1196.                  break;
  1197.  
  1198.         default        : ERROR(line) "Improper left hand side"
  1199.                  EEND;
  1200.         }
  1201.     }
  1202.     }
  1203.     return bs;
  1204. }
  1205.  
  1206. static List local eqnsToBindings(es)   /* Convert list of equations to list*/
  1207. List es; {                   /* of typed bindings           */
  1208.     List bs = extractBindings(es);
  1209.     map1Proc(addSigDecl,bs,extractSigdecls(es));
  1210.     return bs;
  1211. }
  1212.  
  1213. static Void local notDefined(line,bs,v)/* check if name already defined in */
  1214. Int  line;                   /* list of bindings           */
  1215. List bs;
  1216. Cell v; {
  1217.     if (nonNull(findBinding(textOf(v),bs))) {
  1218.     ERROR(line) "\"%s\" multiply defined", textToStr(textOf(v))
  1219.     EEND;
  1220.     }
  1221. }
  1222.  
  1223. static Cell local findBinding(t,bs)    /* look for binding for variable t  */
  1224. Text t;                    /* in list of bindings bs       */
  1225. List bs; {
  1226.     for (; nonNull(bs); bs=tl(bs))
  1227.     if (isVar(fst(hd(bs)))) {              /* function-binding? */
  1228.         if (textOf(fst(hd(bs)))==t)
  1229.         return hd(bs);
  1230.     }
  1231.     else if (nonNull(varIsMember(t,fst(hd(bs))))) /* pattern-binding?  */
  1232.         return hd(bs);
  1233.     return NIL;
  1234. }
  1235.  
  1236. static Void local addSigDecl(bs,sigDecl)/* add type information to bindings*/
  1237. List bs;                   /* :: [Binding]               */
  1238. Cell sigDecl; {                /* :: (Line,[Var],Type)           */
  1239.     Int  line = intOf(fst3(sigDecl));
  1240.     Cell vs   = snd3(sigDecl);
  1241.     Cell type = checkSigType(line,"type declaration",hd(vs),thd3(sigDecl));
  1242.  
  1243.     map3Proc(setType,line,type,bs,vs);
  1244. }
  1245.  
  1246. static Void local setType(line,type,bs,v)
  1247. Int  line;                   /* Set type of variable           */
  1248. Cell type;
  1249. Cell v;
  1250. List bs; {
  1251.     Text t = textOf(v);
  1252.     Cell b = findBinding(t,bs);
  1253.  
  1254.     if (isNull(b)) {
  1255.     ERROR(line) "Type declaration for variable \"%s\" with no body",
  1256.             textToStr(t)
  1257.     EEND;
  1258.     }
  1259.  
  1260.     if (isVar(fst(b))) {                  /* function-binding? */
  1261.     if (isNull(bindingType(b))) {
  1262.         bindingType(b) = type;
  1263.         return;
  1264.     }
  1265.     }
  1266.     else {                          /* pattern-binding?  */
  1267.     List vs = fst(b);
  1268.     List ts = bindingType(b);
  1269.  
  1270.     if (isNull(ts))
  1271.         bindingType(b) = ts = copy(length(vs),NIL);
  1272.  
  1273.     while (nonNull(vs) && t!=textOf(hd(vs))) {
  1274.         vs = tl(vs);
  1275.         ts = tl(ts);
  1276.     }
  1277.  
  1278.     if (nonNull(vs) && isNull(hd(ts))) {
  1279.         hd(ts) = type;
  1280.         return;
  1281.     }
  1282.     }
  1283.  
  1284.     ERROR(line) "Repeated type declaration for \"%s\"", textToStr(t)
  1285.     EEND;
  1286. }
  1287.  
  1288. /* --------------------------------------------------------------------------
  1289.  * To facilitate dependency analysis, lists of bindings are temporarily
  1290.  * augmented with an additional field, which is used in two ways:
  1291.  * - to build the `adjacency lists' for the dependency graph. Represented by
  1292.  *   a list of pointers to other bindings in the same list of bindings.
  1293.  * - to hold strictly positive integer values (depth first search numbers) of
  1294.  *   elements `on the stack' during the strongly connected components search
  1295.  *   algorithm, or a special value mkInt(0), once the binding has been added
  1296.  *   to a particular strongly connected component.
  1297.  *
  1298.  * Using this extra field, the type of each list of declarations during
  1299.  * dependency analysis is [Binding'] where:
  1300.  *
  1301.  *    Binding' ::= (Var, (Dep, (Type, [Alt])))          -- function binding
  1302.  *        |  ([Var], (Dep, (Type, (Pat,Rhs))))  -- pattern binding
  1303.  *
  1304.  * ------------------------------------------------------------------------*/
  1305.  
  1306. #define depVal(d) (fst(snd(d)))        /* Access to dependency information */
  1307.  
  1308. static List local dependencyAnal(bs)   /* Separate lists of bindings into  */
  1309. List bs; {                   /* mutually recursive groups in       */
  1310.                        /* order of dependency           */
  1311.  
  1312.     mapProc(addDepField,bs);           /* add extra field for dependents   */
  1313.     mapProc(depBinding,bs);           /* find dependents of each binding  */
  1314.     bs = scc(bs);               /* sort to strongly connected comps */
  1315.     mapProc(remDepField,bs);           /* remove dependency info field       */
  1316.     return bs;
  1317. }
  1318.  
  1319. static List local topDependAnal(bs)    /* Like dependencyAnal(), but at    */
  1320. List bs; {                   /* top level, reporting on progress */
  1321.     List xs;
  1322.     Int  i = 0;
  1323.  
  1324.     setGoal("Dependency analysis",(Target)(length(bs)));
  1325.     mapProc(addDepField,bs);           /* add extra field for dependents   */
  1326.     for (xs=bs; nonNull(xs); xs=tl(xs)) {
  1327.     depBinding(hd(xs));
  1328.     soFar((Target)(i++));
  1329.     }
  1330.     bs = scc(bs);               /* sort to strongly connected comps */
  1331.     mapProc(remDepField,bs);           /* remove dependency info field       */
  1332.     done();
  1333.     return bs;
  1334. }
  1335.  
  1336. static Void local addDepField(b)       /* add extra field to binding to    */
  1337. Cell b; {                   /* hold list of dependents       */
  1338.     snd(b) = pair(NIL,snd(b));
  1339. }
  1340.  
  1341. static Void local remDepField(bs)      /* remove dependency field from       */
  1342. List bs; {                   /* list of bindings           */
  1343.     mapProc(remDepField1,bs);
  1344. }
  1345.  
  1346. static Void local remDepField1(b)      /* remove dependency field from       */
  1347. Cell b; {                   /* single binding           */
  1348.     snd(b) = snd(snd(b));
  1349. }
  1350.  
  1351. static Void local clearScope() {       /* initialise dependency scoping    */
  1352.     bounds   = NIL;
  1353.     bindings = NIL;
  1354.     depends  = NIL;
  1355. }
  1356.  
  1357. static Void local withinScope(bs)      /* enter scope of bindings bs       */
  1358. List bs; {
  1359.     bounds   = cons(NIL,bounds);
  1360.     bindings = cons(bs,bindings);
  1361.     depends  = cons(NIL,depends);
  1362. }
  1363.  
  1364. static Void local leaveScope() {       /* leave scope of last withinScope  */
  1365.     bounds   = tl(bounds);
  1366.     bindings = tl(bindings);
  1367.     depends  = tl(depends);
  1368. }
  1369.  
  1370. /* --------------------------------------------------------------------------
  1371.  * As a side effect of the dependency analysis we also make the following
  1372.  * checks:
  1373.  * - Each lhs is a valid pattern/function lhs, all constructor functions
  1374.  *   have been defined and are used with the correct number of arguments.
  1375.  * - No lhs contains repeated pattern variables.
  1376.  * - Expressions used on the rhs of an eqn should be well formed.  This
  1377.  *   includes:
  1378.  *   - Checking for valid patterns (including repeated vars) in lambda,
  1379.  *     case, and list comprehension expressions.
  1380.  *   - Recursively checking local lists of equations.
  1381.  * - No free (i.e. unbound) variables are used in the declaration list.
  1382.  * ------------------------------------------------------------------------*/
  1383.  
  1384. static Void local depBinding(b)        /* find dependents of binding       */
  1385. Cell b; {
  1386.     Cell defpart = snd(snd(snd(b)));   /* definition part of binding       */
  1387.  
  1388.     hd(depends) = NIL;
  1389.  
  1390.     if (isVar(fst(b))) {           /* function-binding?           */
  1391.     mapProc(depAlt,defpart);
  1392.     }
  1393.     else {                   /* pattern-binding?           */
  1394.     depRhs(snd(defpart));
  1395.     }
  1396.  
  1397.     depVal(b) = hd(depends);
  1398. }
  1399.  
  1400. static Void local depDefaults(c)       /* dependency analysis on defaults  */
  1401. Class c; {                             /* from class definition            */
  1402.     depClassBindings(class(c).defaults);
  1403. }
  1404.  
  1405. static Void local depInsts(in)         /* dependency analysis on instance  */
  1406. Inst in; {                             /* bindings                         */
  1407.     depClassBindings(inst(in).implements);
  1408. }
  1409.  
  1410. static Void local depClassBindings(bs) /* dependency analysis on list of   */
  1411. List bs; {                             /* bindings, possibly containing    */
  1412.     for (; nonNull(bs); bs=tl(bs))     /* NIL bindings ...                 */
  1413.         if (nonNull(hd(bs)))           /* No need to add extra field for   */
  1414.             mapProc(depAlt,name(hd(bs)).defn); /* dependency information.. */
  1415. }
  1416.  
  1417. static Void local depAlt(a)           /* find dependents of alternative   */
  1418. Cell a; {
  1419.     List origBvars = saveBvars();      /* save list of bound variables       */
  1420.     bindPats(rhsLine(snd(a)),fst(a));  /* add new bound vars for patterns  */
  1421.     depRhs(snd(a));               /* find dependents of rhs       */
  1422.     restoreBvars(origBvars);           /* restore original list of bvars   */
  1423. }
  1424.  
  1425. static Void local depRhs(r)           /* find dependents of rhs       */
  1426. Cell r; {
  1427.     switch (whatIs(r)) {
  1428.     case GUARDED : mapProc(depGuard,snd(r));
  1429.                break;
  1430.  
  1431.     case LETREC  : fst(snd(r)) = eqnsToBindings(fst(snd(r)));
  1432.                withinScope(fst(snd(r)));
  1433.                fst(snd(r)) = dependencyAnal(fst(snd(r)));
  1434.                hd(depends) = fst(snd(r));
  1435.                depRhs(snd(snd(r)));
  1436.                leaveScope();
  1437.                break;
  1438.  
  1439.     default      : snd(r) = depExpr(intOf(fst(r)),snd(r));
  1440.                break;
  1441.     }
  1442. }
  1443.  
  1444. static Void local depGuard(g)           /* find dependents of single guarded*/
  1445. Cell g; {                   /* expression               */
  1446.     depPair(intOf(fst(g)),snd(g));
  1447. }
  1448.  
  1449. static Cell local depExpr(line,e)      /* find dependents of expression    */
  1450. Int  line;
  1451. Cell e; {
  1452.     switch (whatIs(e)) {
  1453.  
  1454.     case VARIDCELL    :
  1455.     case VAROPCELL    : return depVar(line,e);
  1456.  
  1457.     case CONIDCELL    :
  1458.     case CONOPCELL    : return conDefined(line,textOf(e));
  1459.  
  1460.     case AP     : depPair(line,e);
  1461.               break;
  1462.  
  1463.     case NAME    :
  1464.     case UNIT    :
  1465.     case TUPLE    :
  1466.     case STRCELL    :
  1467.     case CHARCELL    :
  1468.     case FLOATCELL  :
  1469.     case INTCELL    : break;
  1470.  
  1471.     case COND    : depTriple(line,snd(e));
  1472.               break;
  1473.  
  1474.     case FINLIST    : map1Over(depExpr,line,snd(e));
  1475.               break;
  1476.  
  1477.     case LETREC    : fst(snd(e)) = eqnsToBindings(fst(snd(e)));
  1478.               withinScope(fst(snd(e)));
  1479.               fst(snd(e)) = dependencyAnal(fst(snd(e)));
  1480.               hd(depends) = fst(snd(e));
  1481.               snd(snd(e)) = depExpr(line,snd(snd(e)));
  1482.               leaveScope();
  1483.               break;
  1484.  
  1485.     case LAMBDA    : depAlt(snd(e));
  1486.               break;
  1487.  
  1488.     case LISTCOMP    : depListComp(line,snd(e));
  1489.               break;
  1490.  
  1491.     case ESIGN    : fst(snd(e)) = depExpr(line,fst(snd(e)));
  1492.               snd(snd(e)) = checkSigType(line,
  1493.                              "expression",
  1494.                              fst(snd(e)),
  1495.                              snd(snd(e)));
  1496.               break;
  1497.  
  1498.     case CASE    : fst(snd(e)) = depExpr(line,fst(snd(e)));
  1499.               map1Proc(depCaseAlt,line,snd(snd(e)));
  1500.               break;
  1501.  
  1502.     case ASPAT    : ERROR(line) "Illegal `@' in expression"
  1503.               EEND;
  1504.  
  1505.     case LAZYPAT    : ERROR(line) "Illegal `~' in expression"
  1506.               EEND;
  1507.  
  1508.     case WILDCARD    : ERROR(line) "Illegal `_' in expression"
  1509.               EEND;
  1510.  
  1511.     default     : internal("in depExpr");
  1512.    }
  1513.    return e;
  1514. }
  1515.  
  1516. static Void local depPair(line,e)      /* find dependents of pair of exprs */
  1517. Int  line;
  1518. Cell e; {
  1519.     fst(e) = depExpr(line,fst(e));
  1520.     snd(e) = depExpr(line,snd(e));
  1521. }
  1522.  
  1523. static Void local depTriple(line,e)    /* find dependents of triple exprs  */
  1524. Int  line;
  1525. Cell e; {
  1526.     fst3(e) = depExpr(line,fst3(e));
  1527.     snd3(e) = depExpr(line,snd3(e));
  1528.     thd3(e) = depExpr(line,thd3(e));
  1529. }
  1530.  
  1531. static Void local depListComp(line,e)  /* find dependents of list compr.   */
  1532. Int  line;
  1533. Cell e; {
  1534.     List origBvars = saveBvars();      /* save list of bound variables       */
  1535.     map1Proc(depQual,line,snd(e));
  1536.     fst(e) = depExpr(line,fst(e));
  1537.     restoreBvars(origBvars);
  1538. }
  1539.  
  1540. static Void local depQual(line,qual)   /* find dependents of qualifier       */
  1541. Int  line;
  1542. Cell qual; {
  1543.     switch(whatIs(qual)) {
  1544.     case FROMQUAL : snd(snd(qual)) = depExpr(line,snd(snd(qual)));
  1545.             fst(snd(qual)) = bindPat(line,fst(snd(qual)));
  1546.             break;
  1547.  
  1548.     case QWHERE   : fst(snd(qual)) = bindPat(line,fst(snd(qual)));
  1549.             snd(snd(qual)) = depExpr(line,snd(snd(qual)));
  1550.             break;
  1551.  
  1552.     case BOOLQUAL : snd(qual) = depExpr(line,snd(qual));
  1553.             break;
  1554.     }
  1555. }
  1556.  
  1557. static Void local depCaseAlt(line,a)   /* find dependents of case altern.  */
  1558. Int  line;
  1559. Cell a; {
  1560.     List origBvars = saveBvars();      /* save list of bound variables       */
  1561.     fst(a) = bindPat(line,fst(a));     /* add new bound vars for patterns  */
  1562.     depRhs(snd(a));               /* find dependents of rhs       */
  1563.     restoreBvars(origBvars);           /* restore original list of bvars   */
  1564. }
  1565.  
  1566. static Cell local depVar(line,e)       /* register occurrence of variable  */
  1567. Int line;
  1568. Cell e; {
  1569.     List bounds1   = bounds;
  1570.     List bindings1 = bindings;
  1571.     List depends1  = depends;
  1572.     Text t       = textOf(e);
  1573.     Cell n;
  1574.  
  1575.     while (nonNull(bindings1)) {
  1576.     n = varIsMember(t,hd(bounds1));   /* look for t in bound variables */
  1577.     if (nonNull(n))
  1578.         return n;
  1579.  
  1580.     n = findBinding(t,hd(bindings1)); /* look for t in var bindings    */
  1581.     if (nonNull(n)) {
  1582.        if (!cellIsMember(n,hd(depends1)))
  1583.            hd(depends1) = cons(n,hd(depends1));
  1584.        return (isVar(fst(n)) ? fst(n) : e);
  1585.     }
  1586.  
  1587.     bounds1   = tl(bounds1);
  1588.     bindings1 = tl(bindings1);
  1589.     depends1  = tl(depends1);
  1590.     }
  1591.  
  1592.     if (isNull(n=findName(t))) {           /* check global definitions */
  1593.     ERROR(line) "Undefined variable \"%s\"", textToStr(t)
  1594.     EEND;
  1595.     }
  1596.  
  1597.     return n;
  1598. }
  1599.  
  1600. /* --------------------------------------------------------------------------
  1601.  * Using the dependency graph for a list of bindings, we rearrange the list
  1602.  * into groups of mutually recursive bindings, in order of dependency
  1603.  * (no binding appears in the resulting list before its dependents in other
  1604.  * groups of mutually recursive bindings).  This is achieved using the
  1605.  * standard algorithm described in:
  1606.  * 1) Robert Tarjan, Depth-first search and Linear Graph Algorithms,
  1607.  *    SIAM J COMPUT, vol 1, no 2, June 1972, pp.146-160.
  1608.  * 2) Aho, Hopcroft and Ullman, Design and Analysis of Algorithms,
  1609.  *    Addison Wesley, 1972.  pp.189-195.
  1610.  * The version used here probably owes most to the latter presentation but
  1611.  * has been modified to simplify the algorithm and improve the use of space.
  1612.  * ------------------------------------------------------------------------*/
  1613.  
  1614. #define visited(d) (isInt(depVal(d)))  /* binding already visited ?       */
  1615.  
  1616. static Cell daSccs = NIL;
  1617. static Int  daCount;
  1618.  
  1619. static Int local sccMin(x,y)           /* calculate minimum of x,y (unless */
  1620. Int x,y; {                   /* y is zero)               */
  1621.     return (x<=y || y==0) ? x : y;
  1622. }
  1623.  
  1624. static Int local lowlink(v)           /* calculate `lowlink' of v       */
  1625. Cell v; {
  1626.     Int  low = daCount;
  1627.     Int  dfn = daCount;            /* depth first search no. of v       */
  1628.     List ws  = depVal(v);           /* adjacency list for v           */
  1629.  
  1630.     depVal(v) = mkInt(daCount++);      /* push v onto stack           */
  1631.     push(v);
  1632.  
  1633.     while (nonNull(ws)) {           /* scan adjacency list for v       */
  1634.     Cell w = hd(ws);
  1635.  
  1636.     ws  = tl(ws);
  1637.     low = sccMin(low, (visited(w) ? intOf(depVal(w)) : lowlink(w)));
  1638.     }
  1639.  
  1640.     if (low == dfn) {               /* start a new scc?           */
  1641.     List temp=NIL;
  1642.  
  1643.     do {                   /* take elements from stack       */
  1644.         depVal(top()) = mkInt(0);
  1645.         temp      = cons(top(),temp);
  1646.     } while (pop()!=v);
  1647.  
  1648.     daSccs = cons(temp,daSccs);    /* make new strongly connected comp.*/
  1649.     }
  1650.  
  1651.     return low;
  1652. }
  1653.  
  1654. static List local scc(bs)           /* sort list of bindings with added */
  1655. List bs; {                   /* dependency info into SCCs       */
  1656.     clearStack();
  1657.     daSccs = NIL;               /* clear current list of SCCs       */
  1658.  
  1659.     for (daCount=1; nonNull(bs); bs=tl(bs))     /* visit each binding       */
  1660.     if (!visited(hd(bs)))
  1661.         lowlink(hd(bs));
  1662.  
  1663.     return rev(daSccs);            /* reverse to obtain correct order  */
  1664. }
  1665.  
  1666. /* --------------------------------------------------------------------------
  1667.  * Main static analysis:
  1668.  * ------------------------------------------------------------------------*/
  1669.  
  1670. Void checkExp() {             /* Top level static check on Expr */
  1671.     staticAnalysis(RESET);
  1672.     clearScope();             /* Analyse expression in the scope*/
  1673.     withinScope(NIL);             /* of no local bindings       */
  1674.     inputExpr = depExpr(0,inputExpr);
  1675.     leaveScope();
  1676.     staticAnalysis(RESET);
  1677. }
  1678.  
  1679. Void checkDefns() {             /* Top level static analysis       */
  1680.     staticAnalysis(RESET);
  1681.  
  1682.     mapProc(checkSynonym,synonymDefns);  /* Check type synonym definitions */
  1683.     mapProc(checkData,dataDefns);     /* ... and data type definitions  */
  1684.     mapProc(tyconRank,synonymDefns);     /* Calculate synonym ranks       */
  1685.     dataDefns     = NIL;          /* Discard lists of definitions   */
  1686.     synonymDefns = NIL;
  1687.  
  1688.     mapProc(checkClassDefn,classDefns);  /* Process class definitions       */
  1689.     mapProc(checkInstDefn,instDefns);    /* Process instance definitions   */
  1690.  
  1691.     valDefns = eqnsToBindings(valDefns); /* translate value equations       */
  1692.     map1Proc(opDefined,valDefns,opDefns);/* check all declared ops bound   */
  1693.     mapProc(allNoPrevDef,valDefns);     /* check against previous defns   */
  1694.  
  1695.     clearScope();
  1696.     withinScope(valDefns);
  1697.     valDefns = topDependAnal(valDefns);  /* top level dependency ordering  */
  1698.     mapProc(depDefaults,classDefns);     /* dep. analysis on class defaults*/
  1699.     mapProc(depInsts,instDefns);         /* dep. analysis on inst defns    */
  1700.     leaveScope();
  1701.  
  1702.     staticAnalysis(RESET);
  1703. }
  1704.  
  1705. static Void local opDefined(bs,op)     /* check that op bound in bs       */
  1706. List bs;                 /* (or in current module for       */
  1707. Cell op; {                 /* constructor functions etc...)  */
  1708.     Name n;
  1709.  
  1710.     if (isNull(findBinding(textOf(op),bs))
  1711.            && (isNull(n=findName(textOf(op))) || !nameThisModule(n))) {
  1712.     ERROR(0) "No top level definition for operator symbol \"%s\"",
  1713.          textToStr(textOf(op))
  1714.     EEND;
  1715.     }
  1716. }
  1717.  
  1718. static Void local allNoPrevDef(b)     /* ensure no previous bindings for*/
  1719. Cell b; {                 /* variables in new binding       */
  1720.     if (isVar(fst(b)))
  1721.     noPrevDef(rhsLine(snd(hd(snd(snd(b))))),fst(b));
  1722.     else {
  1723.     Int line = rhsLine(snd(snd(snd(b))));
  1724.     map1Proc(noPrevDef,line,fst(b));
  1725.     }
  1726. }
  1727.  
  1728. static Void local noPrevDef(line,v)     /* ensure no previous binding for */
  1729. Int  line;                 /* new variable           */
  1730. Cell v; {
  1731.     Name n = findName(textOf(v));
  1732.  
  1733.     if (isNull(n)) {
  1734.     n            = newName(textOf(v));
  1735.     name(n).defn = PREDEFINED;
  1736.     }
  1737.     else if (name(n).defn!=PREDEFINED) {
  1738.     ERROR(line) "Attempt to redefine variable \"%s\"",
  1739.             textToStr(name(n).text)
  1740.     EEND;
  1741.     }
  1742.     name(n).line = line;
  1743. }
  1744.  
  1745. /* --------------------------------------------------------------------------
  1746.  * Static Analysis control:
  1747.  * ------------------------------------------------------------------------*/
  1748.  
  1749. Void staticAnalysis(what)
  1750. Int what; {
  1751.     switch (what) {
  1752.     case INSTALL :
  1753.     case RESET   : daSccs    = NIL;
  1754.                patVars    = NIL;
  1755.                bounds    = NIL;
  1756.                bindings = NIL;
  1757.                depends    = NIL;
  1758.                break;
  1759.  
  1760.     case MARK    : mark(daSccs);
  1761.                mark(patVars);
  1762.                mark(bounds);
  1763.                mark(bindings);
  1764.                mark(depends);
  1765.                break;
  1766.     }
  1767. }
  1768.  
  1769. /*-------------------------------------------------------------------------*/
  1770.